home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp.lbr / XLREAD.CQ / xlread.c
Text File  |  1985-06-03  |  13KB  |  461 lines
  1.  
  2.                   /* xlread - xlisp expression input routine */
  3.  
  4. #ifdef CI_86
  5. #include "a:stdio.h"
  6. #include "xlisp.h"
  7. #endif
  8.  
  9. #ifdef AZTEC
  10. #include "a:stdio.h"
  11. #include "xlisp.h"
  12. #endif
  13.  
  14. #ifdef unix
  15. #include <stdio.h>
  16. #include <ctype.h>
  17. #include <xlisp.h>
  18. #endif
  19.  
  20.                            /* global variables */
  21.  
  22. struct node *oblist;
  23.  
  24.                           /* external variables */
  25.  
  26. extern struct node *xlstack;
  27. extern int (*xlgetc)();
  28. extern int xlplevel;
  29.  
  30.                             /* local variables */
  31.  
  32. static int savech;
  33.  
  34.          /* forward declarations (the extern hack is for decusc) */
  35.  
  36. extern struct node *parse();
  37. extern struct node *plist();
  38. extern struct node *pstring();
  39. extern struct node *pnumber();
  40. extern struct node *pquote();
  41. extern struct node *pname();
  42.  
  43. #ifdef REALS
  44. extern struct node *pfloat();
  45. #endif
  46.  
  47.                      /**************************************
  48.                      *  xlread - read an xlisp expression  *
  49.                      **************************************/
  50.  
  51. struct node *xlread()
  52. {
  53.     savech = -1;                       /* initialize */
  54.     xlplevel = 0;
  55.  
  56.     return (parse());                  /* Parse an expression */
  57. }
  58.  
  59.  
  60.                      /**************************************
  61.                      *  parse - parse an xlisp expression  *
  62.                      **************************************/
  63.  
  64. static struct node *parse()
  65. {
  66.     int ch;
  67.  
  68.     while (TRUE)                        /* Look for a node, skipp comments */
  69.     {
  70.         switch (ch = nextch())          /* Switch on next character */
  71.         {
  72.         case '\'':                      /* a quoted expression */
  73.                 return (pquote());
  74.  
  75.         case '(':                       /* a sublist */
  76.                 return (plist());
  77.  
  78.         case ')':                       /* closing paren - shouldn't happen */
  79.                 xlfail("extra right paren");
  80.  
  81.         case '.':
  82. #ifdef REALS
  83.                 return (pfloat(0));     /* Real fractional only */
  84. #else
  85.                 xlfail("misplaced dot");/* dot - shouldn't happen */
  86. #endif
  87.  
  88.         case ';':                       /* a comment */
  89.                 pcomment();
  90.                 break;
  91.  
  92.         case '"':                       /* a string */
  93.                 return (pstring());
  94.  
  95.         default:
  96.                 if (isdigit(ch))        /* a number */
  97.                     return (pnumber(1));
  98.                 else if (issym(ch))     /* a name */
  99.                     return (pname());
  100.                 else
  101.                     xlfail("invalid character");
  102.         }
  103.     }
  104. }
  105.  
  106.  
  107.                         /*******************************
  108.                         *  pcomment - parse a comment  *
  109.                         *******************************/
  110.  
  111. static pcomment()
  112. {
  113.     while (getch() != '\n')                 /* Skip to end of line */
  114.         ;
  115. }
  116.  
  117.  
  118.                            /*************************
  119.                            *  plist - parse a list  *
  120.                            *************************/
  121.  
  122. static struct node *plist()
  123. {
  124.     struct node *oldstk,val,*lastnptr,*nptr;
  125.     int ch;
  126.  
  127.     xlplevel += 1;                     /* Increment nesting level */
  128.     oldstk = xlsave(&val,NULL);        /* Create .... */
  129.     savech = -1;                       /* Skip opend paren */
  130.  
  131.                        /* keep appending nodes until a closing paren is found */
  132.     for (lastnptr = NULL; (ch = nextch()) > 0 && ch != ')'; lastnptr = nptr)
  133.     {
  134.         if (ch == '.')                 /* Check for a dotted pair */
  135.         {
  136.             savech = -1;               /* Skip the dot */
  137.  
  138.             if (lastnptr == NULL)      /* Make sure there is a node */
  139.                 xlfail("invalid dotted pair");
  140.  
  141.             lastnptr->n_listnext = parse();      /* Parse expression */
  142.  
  143.             if (nextch() != ')')       /* Check for closing paren */
  144.                 xlfail("invalid dotted pair");
  145.  
  146.             break;                     /* Done with this list */
  147.         }
  148.  
  149.         nptr = newnode(LIST);          /* Allocate and link new node */
  150.         if (lastnptr == NULL)
  151.             val.n_ptr = nptr;
  152.         else
  153.             lastnptr->n_listnext = nptr;
  154.  
  155.         nptr->n_listvalue = parse();   /* Initialize it */
  156.     }
  157.  
  158.     savech = -1;                       /* Skip the closing paren */
  159.  
  160.     xlstack = oldstk;                  /* Restore previous stack frame */
  161.     xlplevel -= 1;                     /* Decrement nesting level */
  162.  
  163.     return (val.n_ptr);                /* Successful return */
  164. }
  165.  
  166.                          /*****************************
  167.                          *  pstring - parse a string  *
  168.                          *****************************/
  169.  
  170. static struct node *pstring()
  171. {
  172.     struct node *oldstk,val;
  173.     char sbuf[STRMAX+1];
  174.     int ch,i,d1,d2,d3;
  175.  
  176.     oldstk = xlsave(&val,NULL);             /* Create a new stack frame */
  177.     savech = -1;                            /* Skip opening quote */
  178.  
  179.                                             /* loop looking for a closing qte */
  180.     for (i = 0; i < STRMAX && (ch = getch()) != '"'; i++)
  181.     {
  182.         switch (ch)
  183.         {
  184.         case '\\':
  185.                 switch (ch = getch())
  186.                 {
  187.                 case 'e':
  188.                         ch = '\033';
  189.                         break;
  190.  
  191.                 case 'n':
  192.                         ch = '\n';
  193.                         break;
  194.  
  195.                 case 'r':
  196.                         ch = '\r';
  197.                         break;
  198.  
  199.                 case 't':
  200.                         ch = '\t';
  201.                         break;
  202.  
  203.                 case '0':
  204.                 case '1':
  205.                 case '2':
  206.                 case '3':
  207.                 case '4':
  208.                 case '5':
  209.                 case '6':
  210.                 case '7':
  211.                         d1 = ch - '0';
  212.                         while (((ch = getch()) >= '0') && (ch < '8'))
  213.                             d1 = d1 <<3 + (ch - '0');
  214.                         ch = d1;
  215.                         break;
  216.  
  217.                 default:
  218.                         break;
  219.                 }
  220.         }
  221.         sbuf[i] = ch;
  222.     }
  223.     sbuf[i] = 0;
  224.  
  225.     val.n_ptr = newnode(STR);               /* Initialize the node */
  226.     val.n_ptr->n_str = strsave(sbuf);
  227.  
  228.     xlstack = oldstk;                       /* Restore old stack frame */
  229.     return (val.n_ptr);                     /* .. and return */
  230. }
  231.  
  232.  
  233. #ifdef REALS
  234.             /********************************************************
  235.             *  pfloat - parse the fractional part of a real number  *
  236.             ********************************************************/
  237.  
  238. static struct node *pfloat(i)
  239.     int i;
  240. {
  241.     struct node *val;
  242.     int ch;
  243.     long float rval = (float) ((i<0) ? -i : i), fp= 1;
  244.  
  245.     for ( ; isdigit(ch = thisch()); savech = -1)
  246.         rval = rval + (ch - '0')/(fp *= 10);
  247.  
  248.     if (issym(ch))                     /* ensure correct termination */
  249.         xlfail("badly formed number");
  250.  
  251.     val = newnode(REAL);               /* Initialze the new node */
  252.     val->n_real = (i < 0) ? -rval : rval;
  253.  
  254.     return (val);
  255. }
  256. #endif
  257.  
  258.                          /*****************************
  259.                          *  pnumber - parse a number  *
  260.                          *****************************/
  261.  
  262. static struct node *pnumber(sign)
  263.     int sign;
  264. {
  265.     struct node *val;
  266.     int ch,ival = 0;
  267.  
  268.     for ( ; isdigit(ch = thisch()); savech = -1)      /* loop while digits */
  269.         ival = ival * 10 + ch - '0';
  270.  
  271. #ifdef REALS
  272.     if (ch == '.')
  273.     {
  274.          savech = -1;
  275.          return pfloat(sign*ival);
  276.     }
  277. #endif
  278.  
  279.     if (issym(ch))                     /* ensure correct termination */
  280.         xlfail("badly formed number");
  281.  
  282.     val = newnode(INT);                /* Initialze the new node */
  283.     val->n_int = sign * ival;
  284.  
  285.     return (val);
  286. }
  287.  
  288.               /***************************************************
  289.               *  xlenter - enter a symbol into the symbol table  *
  290.               ***************************************************/
  291.  
  292. struct node *xlenter(sname)
  293.     char *sname;
  294. {
  295.     struct node *sptr;
  296.  
  297.     if (strcmp(sname,"nil") == 0)      /* Check for nil */
  298.         return (NULL);
  299.  
  300.     if (oblist == NULL)                /* Create oblist if required */
  301.     {
  302.         oblist = newnode(SYM);
  303.         oblist->n_symname = strsave("oblist");
  304.         oblist->n_symvalue = newnode(LIST);
  305.         oblist->n_symvalue->n_listvalue = oblist;
  306.     }
  307.  
  308.     sptr = oblist->n_symvalue;         /* check for symbol already in table */
  309.     while (sptr != NULL)
  310.     {
  311.         if (sptr->n_listvalue == NULL)
  312.         {
  313.             printf("bad oblist\n");
  314.             sptr = oblist->n_symvalue;
  315.             while (sptr != NULL)
  316.             {
  317.                  if (sptr->n_listvalue == NULL)
  318.                      xlfail("end oblist");
  319.                  printf("\n%s",sptr->n_listvalue->n_symname);
  320.                  sptr = sptr->n_listnext;
  321.              }
  322.         }
  323.         else if (sptr->n_listvalue->n_symname == NULL)
  324.             printf("bad oblist symbol\n");
  325.         else
  326.         if (strcmp(sptr->n_listvalue->n_symname,sname) == 0)
  327.             return (sptr->n_listvalue);
  328.         sptr = sptr->n_listnext;
  329.     }
  330.  
  331.     sptr = newnode(LIST);              /* Create and link new symbol */
  332.     sptr->n_listnext = oblist->n_symvalue;
  333.     oblist->n_symvalue = sptr;
  334.     sptr->n_listvalue = newnode(SYM);
  335.     sptr->n_listvalue->n_symname = strsave(sname);
  336.  
  337.     return (sptr->n_listvalue);
  338. }
  339.  
  340.  
  341.                     /***************************************
  342.                     *  pquote - parse a quoted expression  *
  343.                     ***************************************/
  344.  
  345. static struct node *pquote()
  346. {
  347.     struct node *oldstk,val;
  348.  
  349.     oldstk = xlsave(&val,NULL);             /* Create new stack frame */
  350.     savech = -1;                            /* Skip the quote character */
  351.  
  352.     val.n_ptr = newnode(LIST);              /* Allocate two new nodes */
  353.     val.n_ptr->n_listvalue = xlenter("quote");
  354.     val.n_ptr->n_listnext = newnode(LIST);
  355.     val.n_ptr->n_listnext->n_listvalue = parse();
  356.  
  357.     xlstack = oldstk;                       /* Restore old stack frame */
  358.     return (val.n_ptr);                     /* .. return quoted expression */
  359. }
  360.  
  361.  
  362.                         /********************************
  363.                         *  pname - parse a symbol name  *
  364.                         ********************************/
  365.  
  366. static struct node *pname()
  367. {
  368.     char sname[STRMAX+1];
  369.     int ch,i;
  370.  
  371.     ch = sname[0] = getch();                /* Get first character */
  372.     if (ch == '+' || ch == '-')             /* Check for signed number */
  373.     {
  374.         if (isdigit(thisch()))
  375.             return (pnumber(ch == '+' ? 1 : -1));
  376.     }
  377.  
  378.     for (i = 1; i < STRMAX && issym(thisch()); i++)   /* get symbol name */
  379.         sname[i] = getch();
  380.     sname[i] = 0;
  381.  
  382.     return (xlenter(sname));                /* Initialize value */
  383. }
  384.  
  385.  
  386.                /**************************************************
  387.                *  nextch - look at the next non-blank character  *
  388.                **************************************************/
  389.  
  390. static int nextch()
  391. {
  392.     while (isspace(thisch()))               /* Find non blank character */
  393.         savech = -1;
  394.  
  395.     return savech;                          /* .. and return it */
  396. }
  397.  
  398.  
  399.                   /*******************************************
  400.                   *  thisch - look at the current character  *
  401.                   *******************************************/
  402.  
  403. static int thisch()
  404. {
  405.     return (savech = getch());         /* return and save next character */
  406. }
  407.  
  408.  
  409.                       /***********************************
  410.                       *  getch - get the next character  *
  411.                       ***********************************/
  412.  
  413. static int getch()
  414. {
  415.     int ch;
  416.  
  417.     if ((ch = savech) >= 0)            /* Check for saved character */
  418.         savech = -1;
  419.     else
  420.         ch = (*xlgetc)();
  421.  
  422.     if (ch == EOF)                     /* Check for abort character */
  423.         if (xlplevel > 0)
  424.         {
  425.             putchar('\n');
  426.             xltin(FALSE);
  427.             xlfail("input aborted");
  428.         }
  429.         else
  430.             exit();
  431.  
  432.     return (ch);                       /* Return char */
  433. }
  434.  
  435.  
  436.         /****************************************************************
  437.         *  issym - check whether a character if valid in a symbol name  *
  438.         ****************************************************************/
  439.  
  440. static int issym(ch)
  441.   int ch;
  442. {
  443.     if (isspace(ch))
  444.         return FALSE;
  445.  
  446.     switch (ch)
  447.     {
  448.     case ' ':
  449.     case '(':
  450.     case ')':
  451.     case ';':
  452.     case '.':
  453.     case '"':
  454.     case '\\':
  455.         return (FALSE);
  456.  
  457.     default:
  458.         return (TRUE);
  459.     }
  460. }
  461.